home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-kb-domain.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  4.6 KB  |  156 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-kb-domain.lisp
  3. ; Description:  
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      19-Mar-93
  6. ; Modified:     Wed Aug  4 20:43:54 1993 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1993, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. (IN-PACKAGE  "ZEBU")
  18. (require "zebu-aux")
  19. (provide "zebu-kb-domain")
  20. ;----------------------------------------------------------------------------;
  21. ; for-each-supertype
  22. ;-------------------
  23. ; Iterate fn over all supertypes of type. Type is the label of a
  24. ; type-tree-node in *domain-HT*
  25. ; Note that every type is its own supertype.
  26.  
  27. (defun for-each-supertype (fn type &optional errorp)
  28.   (let ((node (gethash type *domain-HT*)))
  29.     (labels ((doit (node)
  30.            (when (type-tree-node-p node)
  31.          (funcall fn node)
  32.          (doit (type-tree-node--supertype node)))))
  33.       (if node
  34.       (doit node)
  35.     (when errorp
  36.       (KB-type-error type))))))
  37.  
  38. ;----------------------------------------------------------------------------;
  39. ; KB-legal-slot-p
  40. ;----------------
  41. ; Is slot-label a legal name of a slot of a type named TYPE?
  42. ; EXPORTED
  43. (defun KB-legal-slot-p (type slot-label)
  44.   (for-each-supertype #'(lambda (node)
  45.               (dolist (slot (type-tree-node--slots node))
  46.                 (when (eq (if (consp slot)
  47.                       (car slot)
  48.                     slot)
  49.                       slot-label)
  50.                   (return-from KB-legal-slot-p t))))
  51.               type
  52.               t))
  53.  
  54. ;----------------------------------------------------------------------------;
  55. ; KB-slot-type
  56. ;-------------
  57. ; slot-label is a KB-legal-slot-p type
  58. ; if slot-label has a type restriction (<slot-label> <type-restriction>)
  59. ;    this restriction will be returned
  60. ; else :TOP wil be returned
  61. ; EXPORTED
  62. (defun KB-slot-type (type slot-label)
  63.   (for-each-supertype
  64.    #'(lambda (node)
  65.        (dolist (slot (type-tree-node--slots node))
  66.      (if (consp slot)
  67.          (when (eq (car slot) slot-label)
  68.            (return-from KB-slot-type (cadr slot)))
  69.        (when (eq slot slot-label)
  70.          (return-from KB-slot-type :TOP)))))
  71.    type
  72.    t)
  73.   (error "~a is not a slot of ~a" slot-label type)
  74.   )
  75.  
  76. ;----------------------------------------------------------------------------;
  77. ; kb-slots
  78. ;---------
  79. ; given a type name, return its slots
  80. ; a slot may be a list (<slot-name> <type-name>)
  81. ; EXPORTED
  82. (defun kb-slots (type &aux slots)
  83.   (for-each-supertype
  84.    #'(lambda (n)
  85.        (setq slots (append (type-tree-node--slots n) slots)))
  86.    type
  87.    t)
  88.   slots)
  89.  
  90. ;----------------------------------------------------------------------------;
  91. ; kb-supertype
  92. ;-------------
  93. ; given a type name, return its supertype
  94. ; the top type is named :TOP and its supertype is :TOP
  95. ; EXPORTED
  96. (defun kb-supertype (type)
  97.   (let ((node (gethash type *domain-HT*)))
  98.     (if node
  99.     (if (eq *domain-type-hierarchy* node)
  100.         ':TOP
  101.       (type-tree-node--label
  102.        (type-tree-node--supertype node)))
  103.       (KB-type-error type))))
  104.  
  105. ;----------------------------------------------------------------------------;
  106. ; kb-subtypes
  107. ;------------
  108. ; given a type name, return a list of its subtypes
  109. ; EXPORTED
  110. (defun kb-subtypes (type)
  111.   (let ((node (gethash type *domain-HT*)))
  112.     (if node
  113.     (mapcar #'type-tree-node--label
  114.         (type-tree-node--subtypes node))
  115.        (KB-type-error type))))
  116.  
  117. (defun KB-type-error (type)
  118.   (error "~a is not a KB-type" type))
  119.  
  120. (defun KB-type-name-p (item)
  121.   ;; if ITEM is the name of a subtype of KB-domain
  122.   (not (null (gethash item *domain-HT*))))
  123.  
  124. #|| test
  125. (zb:compile-slr-grammar (merge-pathnames "arith-exp.zb"
  126.                      user::*ZEBU-test-directory*)
  127.             :output-file (merge-pathnames
  128.                       "binary/arith-exp.tab"
  129.                       user::*ZEBU-test-directory*)
  130.             :grammar (find-grammar "zebu-mg"))
  131. (zb:zebu-load-file (merge-pathnames "binary/arith-exp.tab"
  132.                     user::*ZEBU-test-directory*))
  133. (ds:load-system 'user::Zebu-rr)
  134. (KB-slot-type 'user::Mult-op 'user::-arg1)
  135. (kb-slots 'user::Plus-op)
  136. (kb-slots 'user::Factor)
  137. (kb-supertype 'user::Factor)
  138. (kb-supertype 'user::ARITH-EXP)
  139. (kb-supertype 'KB-DOMAIN)
  140. (kb-supertype 'KB-SEQUENCE)
  141. (kb-supertype ':TOP)
  142.  
  143. (kb-subtypes ':TOP)
  144. (KB-type-name-p 'IDENTIFIER)
  145. (KB-type-name-p 'KB-DOMAIN)
  146. (KB-subtypes 'KB-DOMAIN)
  147. (kb-subtypes 'user::ARITH-EXP)
  148. (kb-subtypes 'user::+-OP)
  149. (kb-slots    'user::+-OP)
  150.  
  151. ||#
  152.  
  153. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  154. ;;                         End of zebu-kb-domain.lisp
  155. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  156.